{-# OPTIONS_GHC -XNoMonomorphismRestriction #-}
module Text.XML.Xmlable.Xmlable where

import Control.Monad.Identity
import Control.Monad.Error
import Control.Monad.ErrorMonoid
import Control.Monad.State
import Control.Monad.Reader
import Data.Maybe
import GHC.Real(Ratio)
import Control.Arrow((***), (&&&), first, second)
import Data.Char(toUpper, isDigit)
import Data.Function(on)
import Data.Monoid
import Data.List
-- import GHC.Exts(the)
import qualified Data.Map as Map
--import Debug.Trace

type XName = String
data Xml =
    ElemB XName Namespaces  |
    ElemE                   |
    Attr XName String       |
    Val String
    deriving (Eq, Show, Read)

data XmlDesc = XtVal | XtAttr String | XtElem String deriving (Eq, Show)
xdName (XtAttr s) = s; xdName (XtElem s) = s; xdName _ = ""
isAttr (XtAttr _) = True; isAttr _ = False
isElem (XtElem _) = True; isElem _ = False
isVal XtVal = True; isVal _ = False

newtype Errors = Errors { errors :: [(Int, String)] } deriving Eq
instance Monoid Errors where
    mempty = Errors []
    mappend a b = case on compare (map fst . take 1 . errors) a b of
        EQ -> Errors $ nub $ on (++) errors a b
        GT -> a
        LT -> b
instance Error Errors where
    noMsg = mempty
    strMsg = (\(a,b) -> Errors [(read a, b)]) . span isDigit
instance Show Errors where
    show = unlines . map snd . errors

data XmlDescCons = XdcVal | XdcAttr String | XdcElem String [XmlDesc] deriving (Eq, Show)
    --  (XmlDesc, [XmlDesc])
xdcName (XdcAttr s) = s; xdcName (XdcElem s _) = s; xdcName _ = ""
xdcFields (XdcElem _ xs) = xs
xdcFields _ = []
   
type XmlDescConsM = Maybe XmlDescCons
type Namespaces = Map.Map String String
type XmlEnv = (XmlDescConsM, Namespaces)
type ParserXml = ReaderT XmlEnv (StateT [(Int, Xml)] (ErrorMonoidT Errors Identity))


xd2xdc (XtElem n) = XdcElem n []; xd2xdc (XtAttr n) = XdcAttr n; xd2xdc XtVal = XdcVal
xdc2xd (XdcElem n _) = XtElem n; xdc2xd (XdcAttr n) = XtAttr n; xdc2xd XdcVal = XtVal
-- xdc2xd x = error $ "Invalid param in xdc2xd " ++ show x

-- changeNames :: (String -> String) -> XmlDescCons
-- changeNames f = second $ map (\x -> x { xdName = f $ xdName x} )
rename m x = Map.findWithDefault x x m

changeXmlDescNameBy :: (String -> String) -> XmlDesc -> XmlDesc
changeXmlDescNameBy f (XtAttr n) = XtAttr $ f n
changeXmlDescNameBy f (XtElem n) = XtElem $ f n
changeXmlDescNameBy _ XtVal = XtVal

changeXmlDescConsNameBy :: (String->String) -> XmlDescCons -> XmlDescCons
changeXmlDescConsNameBy f (XdcAttr n) = XdcAttr $ f n
changeXmlDescConsNameBy f (XdcElem n fs) = XdcElem (f n) fs
changeXmlDescConsNameBy _ x = x

changeXmlDescName :: Map.Map String String -> XmlDesc -> XmlDesc
changeXmlDescName = changeXmlDescNameBy . rename

changeFieldNamesBy :: (String -> String) -> XmlEnv -> XmlEnv
changeFieldNamesBy = first . liftM . chf
    where
        chf f (XdcElem n fs) = XdcElem n $ map (changeXmlDescNameBy f) fs
        chf f x = x

changeFieldNames :: Map.Map String String -> XmlEnv -> XmlEnv
changeFieldNames = changeFieldNamesBy . rename

changeNamesBy :: (String -> String) -> XmlEnv -> XmlEnv
changeNamesBy = first . liftM . changeXmlDescConsNameBy

changeNames :: Map.Map String String -> XmlEnv -> XmlEnv
changeNames = changeNamesBy . rename

setNewTypeField :: String -> XmlDesc -> XmlEnv -> XmlEnv
setNewTypeField sc d = first $ liftM (\x -> case x of 
        XdcElem n fs 
            | n == sc -> XdcElem n [d]
            | otherwise -> x
        _ -> x
    )

throwErrorX s = get >>= \xs -> throwError $ Errors $ case xs of
        [] -> [(-1, "There is not enough xml data")]
        ((n,x):_) -> [(n, s ++ " at " ++ show (map snd $ takeWhile ((==n) . fst) xs) ++ ". Position = " ++ show n)]
bindX m s = m `catchError` (throwError . Errors . map (second $ (s++) . (" -> "++)) . errors)

parseListChar = parseSimple id
parseListSimple = modify (uncurry (++) . (concatMap getList . take 1 &&& drop 1)) >> liftM2 (:) parse parseSafe
    where
        getList (k, x) = map ((,) k) $ case x of
            Attr n v -> map (Attr n) $ words v
            Val v -> map Val $ words v
parseListElem = liftM (take 1) get >>= \xml -> liftM2 (:) parse (local (first $ Just . fromMaybe (getEnv xml)) parseSafe)
    where
        getEnv [(_, Attr n _)] = XdcAttr n; getEnv [(_, Val _)] = XdcVal; getEnv [(_, ElemB n _)] = XdcElem n []
        getEnv x =  error $ "Error in list parsing (getEnv). Param: " ++ show x

class Xmlable a where
    parse :: ParserXml a
    parseZero :: ParserXml a
    parseZero = parseZeroS ""
    parseZeroS :: String -> ParserXml a
    parseZeroS = throwErrorX . ("There is no parseZero for the type " ++)
    parseSafe :: ParserXml a
    parseSafe = parse `mplus` parseZero
    parseList :: ParserXml [a]
    parseList = parseListElem

    toXml :: (Maybe XmlDesc) -> a -> [Xml]
    toXml = undefined
    -- isChar, fromChar - служебные функции, чтобы отличать строки от списков (как в HaXml)
    isChar :: a -> Bool
    isChar = const False
    xFromChar :: Char -> a
    xFromChar = undefined
    xToChar :: a -> Char
    xToChar = undefined

prefName = (\(a, b) -> if null b then ([], a) else (a, drop 1 b)) . break (==':')    

compWithPrefix x = comp (prefName x) . prefName
    where
        comp (pa,a) (pb, b) = ask >>= \(_, nss) -> return (a == b && Map.lookup pa nss == Map.lookup pb nss)

-- check :: ParserXml [(Int,Xml)]
check = ask >>= \(d, _) -> get >>= \xmls -> -- traceShow (xmls, d) (
        case (xmls, d) of
            (_ : _, Nothing) -> return xmls
            ((_, ElemB n ns) : _, Just (XdcElem n' _)) -> setLocalNS n ns $ checkEA xmls n n' True
            ((_, Attr n _) : _, Just (XdcAttr n')) -> checkEA xmls n n' False
            ((_, Val _) : _, Just XdcVal) -> return xmls
            ([], _) -> throwErrorX "Check error: empty xml data "
            (x, Just y) -> throwErrorX $ "Check error for " ++ show y
    -- )
    where
        checkEA xmls n n' isE = bindX (compWithPrefix n n' >>= 
                guard 
                -- \b-> ask >>= \(_,ns) -> traceShow (n,n',b,ns) (guard b)
                >> return xmls) $
                "Check error (" ++ (if isE then "ElemB " else "Attr ") ++ n ++ " instead of " ++ n' ++ ")"

instance Xmlable Char where
    parse = {- traceShow 1 -} check >>= \xmls -> case xmls of
            (k, Val (z:zs)) : xs -> parse' z zs xs $ (k, Val zs) : xs
            (k, Attr n (z:zs)) : xs -> parse' z zs xs $ (k, Attr n zs) : xs
            (k1, ElemB n ns) : (k2, Val (z:zs)) : (k3, ElemE) : xs -> parse' z zs xs $ (k1, ElemB n ns) : (k2, Val zs) : (k3, ElemE) : xs
            x:xs               -> throwErrorX "Wrong char parsing"
        where
            parse' z zs xs next = put (if null zs then xs else next) >> return z
    parseZero = parseZeroS "Char"
    parseList = parseListChar
    toXml = toXmlSimple (:[])
    isChar = const True
    xFromChar = id
    xToChar = id

parseSimple :: (Show a, Read a) => (String -> String) -> ParserXml a
parseSimple f = {- traceShow 2 -} check >>= \xmls -> case xmls of
            (_, Val v) : xs    -> make v xs
            (_, Attr _ v) : xs -> make v xs
            (_, ElemB _ _) : (_, Val v) : (_, ElemE) : xs -> make v xs
            _               -> throwErrorX "Unknown pattern in parseSimple"
    where
        make v xs = calc (readList ("[" ++ f v ++ "]")) >>= \r -> put xs >> return r
        calc [(ns, s)]
            | null ns || not (null $ tail ns) || not (null s) = throwErrorX $ "Error in parseSimple.calc " ++ show [(ns, s)]
            | otherwise = return $ head ns
        calc x = throwErrorX $ "Error in parseSimple.calc. Not a singleton " ++ show x

toXmlSimple :: (a -> String) -> (Maybe XmlDesc) -> a -> [Xml]
toXmlSimple f (Just d) = case d of
    XtVal -> (:[]) . Val . f
    XtAttr n -> (:[]) . Attr n . f
    XtElem n -> (\s -> [ElemB n mempty, Val s, ElemE]) . f
toXmlSimple f Nothing = toXmlSimple f $ Just XtVal

instance Xmlable Int where
    parse = parseSimple id
    parseZero = parseZeroS "Int"
    parseList = parseListSimple
    toXml = toXmlSimple show
instance Xmlable Integer where
    parse = parseSimple id
    parseZero = parseZeroS "Integer"
    parseList = parseListSimple
    toXml = toXmlSimple show
instance Xmlable Double where
    parse = parseSimple id
    parseZero = parseZeroS "Double"
    parseList = parseListSimple
    toXml = toXmlSimple show
instance Xmlable Float where
    parse = parseSimple id
    parseZero = parseZeroS "Float"
    parseList = parseListSimple
    toXml = toXmlSimple show
instance Xmlable Bool where
    parse = parseSimple initCap
        where
            initCap [] =[]
            initCap (x : xs) = toUpper x : xs
    parseZero = parseZeroS "Bool"
    parseList = parseListSimple
    toXml = toXmlSimple (\b -> if b then "true" else "false")

instance (Read a, Integral a) => Xmlable (GHC.Real.Ratio a) where
    parseZero = parseZeroS "Ratio"
    parse = parseSimple id
    parseList = parseListSimple
    toXml = toXmlSimple show

instance (Xmlable a) => Xmlable [a] where
    {-
    parse = parseList
    -}
    parse = get >>= \xmls -> return (getEnv $ take 1 $ xmls) >>= \desc -> mods xmls (liftM2 (:) parse $ local (first $ Just . fromMaybe desc) parseSafe)
        where
            lm _ _ [] = const (modify (drop 1) >> return [])
            lm k f v = liftM (\r -> if isChar (head r) then map xFromChar v else r) . (modify ((map (\c -> (k, f c)) (words v) ++) . tail) >>)
            
            getEnv [(_, Attr n _)] = XdcAttr n; getEnv [(_, Val _)] = XdcVal; getEnv [(_, ElemB n _)] = XdcElem n []
            getEnv x =  error $ "Error in list parsing (getEnv). Param: " ++ show x
            
            mods ((k, Attr n v):_) = lm k (Attr n) v; mods ((k, Val v):_) = lm k Val v; mods ((_, ElemB _ _):_) = id 
            mods x = const $ throwErrorX "Error in list parsing."
    parseZero = return []
    toXml Nothing xs = toXml (Just XtVal) xs
    toXml jd@(Just d) xs
        | any isChar xs = toXmlSimple (map xToChar) jd xs
        | otherwise = case d of
                XtVal -> (:[]) . Val . drop 1 . concatMap (\(~(Val s)) -> ' ' : s)
                XtAttr n -> (:[]) . Attr n . drop 1 . concatMap (\(~(Attr _ s)) -> ' ' : s)
                XtElem n -> id
            . concatMap (toXml jd) $ xs

noEnv = local $ first $ const Nothing
parseDef = noEnv parse

instance (Xmlable a, Xmlable b) => Xmlable (a,b) where
    parse = liftM2 (,) parseDef parseDef -- (noEnv parse) (noEnv parse)
    toXml _ (a0,a1) = toXml Nothing a0 ++ toXml Nothing a1

instance (Xmlable a, Xmlable b, Xmlable c) => Xmlable (a,b,c) where
    parse = liftM3 (,,) parseDef parseDef parseDef -- (noEnv parse) (noEnv parse) (noEnv parse)
    toXml _ (a0,a1,a2) = toXml Nothing a0 ++ toXml Nothing a1 ++ toXml Nothing a2

instance (Xmlable a) => Xmlable (Maybe a) where
    parse = liftM Just parse
    parseZero = return Nothing
    toXml d = concat . maybeToList . liftM (toXml d)

setEnv' :: XmlEnv -> ParserXml a -> ParserXml a
setEnv' (Just env, ns') = local ((
        let n = xdcName env in 
            Just . (\d -> case d of 
                    XdcAttr "" -> XdcAttr n
                    XdcElem n0 _ 
                        | null n0 -> XdcElem n $ xdcFields env 
                        | otherwise -> XdcElem n0 $ xdcFields env 
                    dd -> dd 
                ) . fromMaybe env
    ) *** Map.union ns')
    
setLocalNS n ns = local (second $ setDefaultNS n . Map.union ns)
    where
        setDefaultNS n m = (\(a,b) -> if null a then m else fromMaybe m $ liftM (\x-> Map.insert "" x m) $ Map.lookup a m) $ prefName n
        
parseElem fp fc = check >>= \xmls -> case xmls of
        (_, ElemB n ns):xs    -> 
            -- trace ("  parseElem!  " ++ show (head xmls)) $ 
            setLocalNS n ns $ drop1 >> fp fc >>= \res -> get >>= \s -> case s of
                (_, ElemE):_ -> drop1 >> return res
                x -> throwErrorX $ se ++ "There is no ElemE. Instead we have " ++ show x
                    -- альтернатива - пропустить все, пока не будет ElemE
        _ -> fp fc
    where
        se = "Error in element parsing (parseElem). "
        drop1 = modify (drop 1)

-- utils

run p e = runIdentity . runErrorT . runErrorMonoidT . runStateT (runReaderT p e) . zip [0..]

eitherParse p e = (\res -> case res of
        Left w -> (Left $ show w, [])
        Right (a,b) -> (Right a, map snd b)
    ) . run p (second Map.fromList e)

run' p e = (\res -> case res of
        Left w -> Left $ show w
        Right (a,b) -> Right a
    ) . run p (second Map.fromList e)

run'' p e = (\res -> case res of
        Left w -> Left w
        Right (a,b) -> Right a
    ) . run p (second Map.fromList e)

run''' p e = (\res -> case res of
        Left w -> Left mempty
        Right (a,b) -> Right a
    ) . run p (second Map.fromList e)
